Unit BListsUnit;

{$mode objfpc}{$H+}

Interface

Uses
  Classes, SysUtils, syncobjs, fgl;

Type

{ BList }

  Generic BList<BManagedClass> = Class
  Private
    bInternalList: TList;
    Function BListCompare(Item1, Item2: Pointer): Integer;

    Function GetItem(aIndex: Integer): BManagedClass;
    Procedure SetItem(aIndex: Integer; Const aValue: BManagedClass);

    Procedure BSort(aLeft, aRight: Integer);
  Public
    Property Items[aIndex: Integer]: BManagedClass
      Read GetItem Write SetItem; Default;

    Procedure Add(Const aValue: BManagedClass);
    Function SafeAdd(Const aValue: BManagedClass;
      Const aExceptionOnDuplicate: Boolean = FALSE): Boolean;
    Function IndexOf(Const aValue: BManagedClass): Integer; Inline;
      Procedure Insert(Const aIndex: Integer; Const aValue: BManagedClass);
    Function Remove(Const aValue: BManagedClass): Integer;
    Procedure Delete(Const aIndex: Integer);
    Procedure Purge;
    Procedure Clear;

    Function Count: Integer;
    Function GetAt(Const aIndex: Integer): BManagedClass;
    Function Find(Const aID: Integer): BManagedClass;
    Function Present(Const aValue: BManagedClass): Boolean; Inline;

    Procedure Load(Const aList: BList);
    Procedure AddList(Const aList: TList);
    Function AsList: Tlist;
    Function AsString: String;

    Procedure Sort;
    Procedure Compare(Const aTarget: BList; Var aLack, aOver: BList);
    Procedure Compare(Const aTarget: BList; Var aSame, aLack, aOver: BList);

    Constructor Build;
    Destructor Burn;
End;

Type

{ BThreadList }

Generic BThreadList<BManagedClass> = Class
  Type BManagedList = Specialize BList<BManagedClass>;
  Protected
    bInternal: BManagedList;
    bSection: TCriticalSection;
  Public
    Procedure Add(Const aValue: BManagedClass);
    Procedure Remove(Const aValue: BManagedClass);
    Procedure Clear; Reintroduce;
    Procedure Purge;
    Procedure Load(Const aList:BManagedList);

    Function LockList: BManagedList;
    Procedure UnlockList;

    Constructor Build;
    Destructor Burn;
End;

Type

{ BLinkedList }

Generic BLinkedList<BManagedClass> = Class
  Type BFlatList = Specialize BList<BManagedClass>;
  Private
    bInternal: TList;
    Function GetFirst: BManagedClass; Inline;
    Function GetLast: BManagedClass; Inline;
  Public
    Property First: BManagedClass Read GetFirst;
    Property Last: BManagedClass Read GetLast;

    Procedure Add(Const aObject: BManagedClass);
    Procedure SafeAdd(Const aObject: BManagedClass); Inline;
    Procedure Insert(aObject: BManagedClass; Const aNext: BManagedClass = nil);

    Procedure Remove(Const aObject: BManagedClass);

    Function Present(Const aObject: BManagedClass): Boolean;

    Procedure Load(Const aList: BLinkedList);
    Function AsList: BFlatList;

    Constructor Build;
    Destructor Burn;
End;

Type

{ BLinkedThreadList }

 Generic BLinkedThreadList<BManagedClass> = Class
  Type BManagedList = Specialize BLinkedList<BManagedClass>;
  Private
    bInternal: BManagedList;
    bSection: TCriticalSection;
  Public
    Procedure Add(Const aObject: BManagedClass);
    Procedure Load(Const aList: BManagedList);

    Procedure Remove(Const aObject: BManagedClass);
    Function LockList: BManagedList;
    Procedure UnlockList;

    Constructor Build;
    Destructor Burn;
End;

    Type

    { BPrimitiveList }

  generic BPrimitiveList<T> = class(TFPSList)
  private
    type
      TCompareFunc = function(const Item1, Item2: T): Integer;
      TTypeList = array[0..MaxGListSize] of T;
      PTypeList = ^TTypeList;
      PT = ^T;
      BPrimitiveListEnumeratorSpec = specialize TFPGListEnumerator<T>;
  {$ifndef OldSyntax}protected var{$else}var protected{$endif}
      FOnCompare: TCompareFunc;
    procedure CopyItem(Src, Dest: Pointer); override;
    procedure Deref(Item: Pointer); override;
    function  Get(Index: Integer): T; {$ifdef CLASSESINLINE} inline; {$endif}
    function  GetList: PTypeList; {$ifdef CLASSESINLINE} inline; {$endif}
    function  ItemPtrCompare(Item1, Item2: Pointer): Integer;
    procedure Put(Index: Integer; const Item: T); {$ifdef CLASSESINLINE} inline; {$endif}
    function GetLast: T; {$ifdef CLASSESINLINE} inline; {$endif}
    procedure SetLast(const Value: T); {$ifdef CLASSESINLINE} inline; {$endif}
    function GetFirst: T; {$ifdef CLASSESINLINE} inline; {$endif}
    procedure SetFirst(const Value: T); {$ifdef CLASSESINLINE} inline; {$endif}
  public
    constructor Create;
    Constructor Build;
    Destructor Burn;
    function Add(const Item: T): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
    function Extract(const Item: T): T; {$ifdef CLASSESINLINE} inline; {$endif}
    property First: T read GetFirst write SetFirst;
    function GetEnumerator: BPrimitiveListEnumeratorSpec; {$ifdef CLASSESINLINE} inline; {$endif}
    function IndexOf(const Item: T): Integer;
    procedure Insert(Index: Integer; const Item: T); {$ifdef CLASSESINLINE} inline; {$endif}
    property Last: T read GetLast write SetLast;
    Procedure Load(Const aList: BPrimitiveList);
    {$ifndef VER2_4}
    procedure Assign(Source: BPrimitiveList);
    {$endif}
    function Remove(const Item: T): Integer; {$ifdef CLASSESINLINE} inline; {$endif}
    procedure Sort(Compare: TCompareFunc);
    property Items[Index: Integer]: T read Get write Put; default;
    property List: PTypeList read GetList;
  end;

Type

{ BPrimitiveThreadList }

  Generic BPrimitiveThreadList<T> = Class
  Type BManagedList = Specialize BPrimitiveList<T>;
  Protected
    bInternal: BManagedList;
    bSection: TCriticalSection;
  Public
    Procedure Add(Const aValue: T);
    Procedure Remove(Const aValue: T);
    Procedure Clear; Reintroduce;

    Procedure Load(Const aList: BManagedList);

    Function LockList: BManagedList;
    Procedure UnlockList;

    Function Present(Const aValue: T): Boolean;

    Function AsList: String;

    Constructor Build;
    Destructor Burn;
End;

Type BStringsList = Specialize BPrimitiveList<String>;
Type BStringsThreadList = Specialize BPrimitiveThreadList<String>;

Type BIntegersList = Specialize BPrimitiveList<Integer>;
Type BIntegersThreadList = Specialize BPrimitiveThreadList<Integer>;

Type BDoublesList = Specialize BPrimitiveList<Double>;
Type BDoublesThreadList = Specialize BPrimitiveThreadList<Double>;

Type BDateTimesList = Specialize BPrimitiveList<TDateTime>;
Type BDateTimesThreadList = Specialize BPrimitiveThreadList<TDateTime>;

Implementation

{ BList }

Function BList.BListCompare(Item1, Item2: Pointer): Integer;
Begin
  If (Item1 = nil) Or (Item2 = nil) Then
    Begin
      If Item1 = nil Then
        If Not(Item2 = nil) Then Result := 1
        Else Result := 0
      Else
        Result := -1
    End
  Else
    Result := BManagedClass(Item2).ID - BManagedClass(Item1).ID;
End;

Function BList.GetItem(aIndex: Integer): BManagedClass;
Begin
  Result := BManagedClass(bInternalList.Items[aIndex]);
end;

Procedure BList.SetItem(aIndex: Integer; Const aValue: BManagedClass);
Begin
  If aValue = nil Then Raise Exception.Create('Attempt of Nill adding');
  bInternalList.Items[aIndex] := aValue;
end;

Procedure BList.Add(Const aValue: BManagedClass);
Begin
  If aValue = nil Then
    Raise Exception.Create('Attempt of Nill adding');
  bInternalList.Add(aValue);
End;

Function BList.SafeAdd(Const aValue: BManagedClass;
  Const aExceptionOnDuplicate: Boolean): Boolean;
Var
  i: Integer;
  aPresent: Boolean;
Begin
  Result := FALSE;
  aPresent := FALSE;
  For i := 0 To Count - 1 Do
    If GetAt(i).Equals(aValue) Then
      Begin
        aPresent := TRUE;
        Break;
      End;
  If aPresent Then
    If aExceptionOnDuplicate Then
      Raise Exception.Create('Value already present in list')
    Else
      Exit;
  Add(aValue);
  Result := TRUE;
End;

Function BList.IndexOf(Const aValue: BManagedClass): Integer;
Begin
  Result := bInternalList.IndexOf(aValue);
End;

Procedure BList.Insert(Const aIndex: Integer; Const aValue: BManagedClass);
Begin
  bInternalList.Insert(aIndex, aValue);
End;

Function BList.Remove(Const aValue: BManagedClass): Integer;
Begin
  Result := bInternalList.Remove(aValue);
End;

Procedure BList.Delete(Const aIndex: Integer);
Begin
  bInternalList.Delete(aIndex);
End;

Procedure BList.Purge;
Var
  i: Integer;
Begin
  For i := 0 To Count - 1 Do
    Items[i].Burn;
  bInternalList.Clear;
End;

Procedure BList.Clear;
Begin
  bInternalList.Clear;
End;

Function BList.Count: Integer;
Begin
  Result := bInternalList.Count;
End;

Function BList.GetAt(Const aIndex: Integer): BManagedClass;
Begin
  If Items[aIndex] = nil Then Raise Exception.Create('HERE!');
  Result := BManagedClass(Items[aIndex]);
End;

Function BList.Find(Const aID: Integer): BManagedClass;
Var
  i: Integer;
Begin
  Result := nil;
  For i := 0 To Count - 1 Do
    If GetAt(i).ID = aID Then
      Begin
        Result := GetAt(i);
        Break;
      End;
End;

Function BList.Present(Const aValue: BManagedClass): Boolean;
Var
  i: Integer;
Begin
  Result := FALSE;
  For i := 0 To Count - 1 Do
    If GetAt(i).Equals(aValue) Then Exit(TRUE);
End;

Procedure BList.Load(Const aList: BList);
Begin
  bInternalList.Clear;
  AddList(aList.bInternalList);
End;

Procedure BList.BSort(aLeft, aRight: Integer);
Var
  i, j: Integer;
  aFirst, aBuffer: BManagedClass;
Begin
  Repeat
    i := aLeft;
    j := aRight;
    aFirst := Items[(aLeft + aRight) div 2];
    Repeat
      While Items[i].ID < aFirst.ID Do
        i += 1;
      While Items[j].ID > aFirst.ID Do
        j -= 1;
      If i <= j Then
        Begin
          aBuffer := Items[i];
          Items[i] := Items[j];
          Items[j] := aBuffer;
          i += 1;
          j -= 1;
        End;
    Until i > j;
    If aLeft < j Then BSort(aLeft, j);
    aLeft := i;
  Until Not(i < aRight);
End;

Procedure BList.AddList(Const aList: TList);
Begin
  bInternalList.AddList(aList);
End;

Function BList.AsList: Tlist;
Begin
  Result := bInternalList;
End;

Function BList.AsString: String;
Var
  i: Integer;
Begin
  Result := '';
  For i := 0 To bInternalList.Count - 1 Do
    Begin
      If Not(Result = '') Then Result += ',';
      Result += IntToStr(BManagedClass(bInternalList[i]).ID);
    End;
End;

Procedure BList.Sort;
Begin
  If Count < 2 Then Exit;
  BSort(0, Count - 1);
End;

Procedure BList.Compare(Const aTarget: BList; Var aLack, aOver: BList);
Var
  aSame: BList;
Begin
  aSame := BList.Build;
  Compare(aTarget, aSame, aLack, aOver);
  aSame.Burn;
End;

Procedure BList.Compare(Const aTarget: BList; Var aSame, aLack, aOver: BList);
Var
  i, j: Integer;
  aID, aTargetID: Integer;
Begin
  If aTarget = nil Then Raise Exception.Create('Illegal nil Target');

  Sort;
  aTarget.Sort;

  i := 0;
  j := 0;
  While TRUE Do
    Begin
      If i = Count Then aID := -1
      Else aID := GetAt(i).ID;
      If j = aTarget.Count Then aTargetID := -1
      Else aTargetID := aTarget.GetAt(j).ID;

      If (aID = -1) And (aTargetID = -1) Then Break;

      If aID = aTargetID Then
        Begin
          aSame.Add(GetAt(i));
          Inc(i);
          Inc(j);
        End
      Else
        Begin
          If ((aID < aTargetID) Or (aTargetID = -1)) And Not(aID = -1) Then
            Begin
              aOver.Add(GetAt(i));
              Inc(i)
            End;
          If ((aID > aTargetID) Or (aID = -1)) And Not(aTargetID = -1) Then
            Begin
              aLack.Add(aTarget.GetAt(j));
              Inc(j);
            End;
      End;
    End;
End;

Constructor BList.Build;
Begin
  bInternalList := TList.Create;
End;

Destructor BList.Burn;
Begin
  bInternalList.Free;
End;

{ BThreadList }

Procedure BThreadList.Add(Const aValue: BManagedClass);
Begin
  bSection.Enter;
  bInternal.Add(aValue);
  bSection.Leave;
End;

Procedure BThreadList.Remove(Const aValue: BManagedClass);
Begin
  bSection.Enter;
  bInternal.Remove(aValue);
  bSection.Leave;
End;

Procedure BThreadList.Clear;
Begin
  bSection.Enter;
  bInternal.Clear;
  bSection.Leave;
End;

Procedure BThreadList.Purge;
Var
  i: Integer;
Begin
  bSection.Enter;
  For i := 0 To bInternal.Count - 1 Do
    bInternal.GetAt(i).Burn;
  bInternal.Clear;
  bSection.Leave;
End;

Procedure BThreadList.Load(Const aList: BManagedList);
Begin
  bSection.Enter;
  bInternal.Load(aList);
  bSection.Leave;
End;

Function BThreadList.LockList: BManagedList;
Begin
  bSection.Enter;
  Result := bInternal;
End;

Procedure BThreadList.UnlockList;
Begin
   bSection.Leave;
End;

Constructor BThreadList.Build;
Begin
  bSection := TCriticalSection.Create;
  bInternal := BManagedList.Build;
End;

Destructor BThreadList.Burn;
Begin
  bInternal.Burn;
  bSection.Free;
End;

{ BLinkedList }

Function BLinkedList.GetFirst: BManagedClass;
Var
  i: Integer;
Begin
  Result := nil;
  For i := 0 To bInternal.Count - 1 Do
    If BManagedClass(bInternal[i]).Prior = nil Then
      Exit(BManagedClass(bInternal[i]));
end;

Function BLinkedList.GetLast: BManagedClass;
Var
  i: Integer;
Begin
  Result := nil;
  For i := 0 To bInternal.Count - 1 Do
    If BManagedClass(bInternal[i]).Next = nil Then
      Exit(BManagedClass(bInternal[i]));
end;

Procedure BLinkedList.Add(Const aObject: BManagedClass);
Begin
  bInternal.Add(aObject);
End;

Procedure BLinkedList.SafeAdd(Const aObject: BManagedClass);
Begin
  If Not(Present(aObject)) Then Add(aObject);
End;

Procedure BLinkedList.Insert(aObject: BManagedClass;Const aNext: BManagedClass);
Var
  aIndex: Integer;
Begin
  If aObject = nil Then Raise Exception.Create('Nil insertion attempted');
  If (aNext = nil) Or (bInternal.Count = 0) Then Add(aObject)
  Else
    Begin
      aIndex := bInternal.IndexOf(aNext);
      If aIndex = -1 Then bInternal.Add(aObject)
      Else bInternal.Insert(aIndex, aObject);
    End;
End;

Procedure BLinkedList.Remove(Const aObject: BManagedClass);
Begin
  If Not(aObject.Prior = nil) Then aObject.Prior.Next := aObject.Next;
  If Not(aObject.Next = nil) Then aObject.Next.Prior := aObject.Prior;
  bInternal.Remove(aObject);
End;

//Procedure BLinkedList.Delete(Const aIndex: Integer);
//Begin
//
//End;
//
Function BLinkedList.Present(Const aObject: BManagedClass): Boolean;
Begin

End;

Procedure BLinkedList.Load(Const aList: BLinkedList);
Begin
  bInternal.Clear;
  bInternal.AddList(aList.bInternal);
End;

Function BLinkedList.AsList: BFlatList;
Begin
  Result :=  BFlatList(bInternal);
End;

Constructor BLinkedList.Build;
Begin
  bInternal := TList.Create;
End;

Destructor BLinkedList.Burn;
Begin
  bInternal.Free;
End;

{ BLinkedThreadList }

Procedure BLinkedThreadList.Add(Const aObject: BManagedClass);
Begin
  bSection.Enter;
  bInternal.Add(aObject);
  bSection.Leave;
End;

Procedure BLinkedThreadList.Load(Const aList: BManagedList);
Begin
  bSection.Enter;
  bInternal.Load(aList);
  bSection.Leave;
End;

Procedure BLinkedThreadList.Remove(Const aObject: BManagedClass);
Begin
  bSection.Enter;
  bInternal.Remove(aObject);
  bSection.Leave;
End;

Function BLinkedThreadList.LockList: BManagedList;
Begin
  bSection.Enter;
  Result := bInternal;
End;

Procedure BLinkedThreadList.UnlockList;
Begin
  bSection.Leave;
End;

Constructor BLinkedThreadList.Build;
Begin
  bSection := TCriticalSection.Create;
  bInternal := BManagedList.Build;
End;

Destructor BLinkedThreadList.Burn;
Begin
  bInternal.Burn;
  bSection.Free;
End;

{ BPrimitiveThreadList }

Procedure BPrimitiveThreadList.Add(Const aValue: T);
Begin
  bSection.Enter;
  bInternal.Add(aValue);
  bSection.Leave;
End;

Procedure BPrimitiveThreadList.Remove(Const aValue: T);
Begin
  bSection.Enter;
  bInternal.Remove(aValue);
  bSection.Leave;
End;

Procedure BPrimitiveThreadList.Clear;
Begin
  bSection.Enter;
  bInternal.Clear;
  bSection.Leave;
End;

Procedure BPrimitiveThreadList.Load(Const aList: BManagedList);
Var
  i: Integer;
Begin
  bInternal.Clear;
  For i := 0 To aList.Count - 1 Do
    bInternal.Add(aList[i]);
End;

Function BPrimitiveThreadList.LockList: BManagedList;
Begin
  bSection.Enter;
  Result := bInternal;
End;

Procedure BPrimitiveThreadList.UnlockList;
Begin
  bSection.Leave;
End;

Function BPrimitiveThreadList.Present(Const aValue: T): Boolean;
Var
  i: Integer;
Begin
  Result := FALSE;
  bSection.Enter;
  For i := 0 To bInternal.Count - 1 Do
    Begin
      If bInternal[i] = aValue Then
        Begin
          Result := TRUE;
          Break;
        End;
    End;
  bSection.Leave;
End;

Function BPrimitiveThreadList.AsList: String;
Var
  i: Integer;
  aValue: T;
  aBuffer: String;
Begin
  Result := '';
  bSection.Enter;
  For i := 0 To bInternal.Count - 1 Do
    Begin
      If Not(Result = '') Then Result += ',';
      aValue := bInternal[i];
      //Str(aValue:0:2, aBuffer);
      Result += aBuffer;
    End;
  bSection.Leave;
End;

Constructor BPrimitiveThreadList.Build;
Begin
  bSection := TCriticalSection.Create;
  bInternal := BManagedList.Create;
End;

Destructor BPrimitiveThreadList.Burn;
Begin
  bInternal.Free;
  bSection.Free;
End;

constructor BPrimitiveList.Create;
begin
  inherited Create(sizeof(T));
end;

procedure BPrimitiveList.CopyItem(Src, Dest: Pointer);
begin
  T(Dest^) := T(Src^);
end;

procedure BPrimitiveList.Deref(Item: Pointer);
begin
  Finalize(T(Item^));
end;

function BPrimitiveList.Get(Index: Integer): T;
begin
  Result := T(inherited Get(Index)^);
end;

function BPrimitiveList.GetList: PTypeList;
begin
  Result := PTypeList(FList);
end;

function BPrimitiveList.ItemPtrCompare(Item1, Item2: Pointer): Integer;
begin
  Result := FOnCompare(T(Item1^), T(Item2^));
end;

procedure BPrimitiveList.Put(Index: Integer; const Item: T);
begin
  inherited Put(Index, @Item);
end;

function BPrimitiveList.Add(const Item: T): Integer;
begin
  Result := inherited Add(@Item);
end;

function BPrimitiveList.Extract(const Item: T): T;
begin
  inherited Extract(@Item, @Result);
end;

function BPrimitiveList.GetFirst: T;
begin
  Result := T(inherited GetFirst^);
end;

procedure BPrimitiveList.SetFirst(const Value: T);
begin
  inherited SetFirst(@Value);
end;

function BPrimitiveList.GetEnumerator: BPrimitiveListEnumeratorSpec;
begin
  Result := BPrimitiveListEnumeratorSpec.Create(Self);
end;

function BPrimitiveList.IndexOf(const Item: T): Integer;
Var
  i: Integer;
begin
  Result := -1;
  For i := 0 To Count - 1 Do
    If (Items[i] = Item) Then Exit(i);
end;

procedure BPrimitiveList.Insert(Index: Integer; const Item: T);
begin
  T(inherited Insert(Index)^) := Item;
end;

function BPrimitiveList.GetLast: T;
begin
  Result := T(inherited GetLast^);
end;

procedure BPrimitiveList.SetLast(const Value: T);
begin
  inherited SetLast(@Value);
end;

Procedure BPrimitiveList.Load(Const aList: BPrimitiveList);
Begin
  Assign(aList);
End;

{$ifndef VER2_4}
Procedure BPrimitiveList.Assign(Source: BPrimitiveList);
var
  i: Integer;
begin
  Clear;
  for I := 0 to Source.Count - 1 do
    Add(Source[i]);
End;
{$endif}

function BPrimitiveList.Remove(const Item: T): Integer;
begin
  Result := IndexOf(Item);
  if Result >= 0 then
    Delete(Result);
end;

procedure BPrimitiveList.Sort(Compare: TCompareFunc);
begin
  FOnCompare := Compare;
  inherited Sort(@ItemPtrCompare);
end;

Constructor BPrimitiveList.Build;
Begin
  Inherited Create;
End;

Destructor BPrimitiveList.Burn;
Begin
  Inherited Destroy;
End;

End.
